perm filename MPSUB.F4[MSS,LCS] blob sn#356839 filedate 1978-05-19 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE STRTUP
C00010 ENDMK
CāŠ—;
	SUBROUTINE STRTUP
	COMMON /NAM/NAM
	TYPE 1  
	ACCEPT 2,K
	IF(K.EQ.' ')K='TEST'
	CALL IFILE(1,K)
3	TYPE 4
	ACCEPT 2,NAM
	IF(NAM.EQ.K)GO TO 3
C DON'T USE SAME NAME FOR IN AND OUT
	IF(NAM.EQ.' ')NAM='NOTES'
	CALL OFILE(21,NAM)
C DEFAULT NAM
1	FORMAT(' INPUT NAME = '$)
2	FORMAT(A5)
4	FORMAT(' OUTPUT NAME = '$)
	END

	SUBROUTINE ONEUP(L,J,N)
	DIMENSION L(1)
	J=J+1
	L(J)=N
	END

	FUNCTION NUMS(N)
C FINDS ASCII NUMBER  (NUMS=-1)
	NUMS=0
	IF(N.GE.'0'.AND.N.LE.'9')NUMS=-1
	IF(N.EQ.'.')NUMS=-1
C DOT IS CONSIDERED PART OF A NUMBER
	END

	FUNCTION LETS(N)
C FINDS LETTER  (LETS=-1)
	LETS=0
	IF(N.GE.'A'.AND.N.LE.'Z')LETS=-1
	END

	FUNCTION ISGN(J)
	COMMON /INP/JN,I(1)
	ISGN=JN+1
	N=I(J+1)
	IF(N.EQ.'+')GO TO 1
	IF(N.NE.'-')RETURN
	ISGN=-ISGN
	GO TO 2
1	ISGN=ISGN+100
C FOR SLUR AND BEAM STEM REVERSAL
2	J=J+1
	END
 
	SUBROUTINE I2A(JN,MM,M,N)
	COMMON/NUM/NUM(0/9)
	DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
	K=JN
	N=K/100
	MM=NUM(N)
	K=K-N*100
	N=K/10
	M=NUM(N)
	N=NUM(K-N*10)
C CHANGES 2-DIGIT NUMBERS TO FROM INTEGER TO ASCII
	END
 
	SUBROUTINE A2I(J,N)
	COMMON /INP/JN,I(1) /NUM/NUM(0/9)
	L=N
	N=0
3	DO 1 K=0,9
1	IF(L.EQ.NUM(K))GO TO 2
2	N=N*10+K
	L=I(J+1)
	IF(NUMS(L).EQ.0)RETURN
	J=J+1
	GO TO 3
	END
 
	SUBROUTINE UPDATE(N,K)
	DIMENSION N(1)
	COMMON /J/J,JJ  /INP/JN,I(1)
	DO 1 L=JJ,J
	K=K+1
1	N(K)=I(L)
	END
 
	FUNCTION LETNUM(N)
	COMMON /J/J,JJ  /INP/JN,I(1)
	1 /MKS/ MKS(11)
	DATA MKS/'/',';','<','>',-19728949184,-18655207360,'(',')','.'
	1,'-','*'/
C THE GIANT NUMBERS ARE FOR [ AND ]
1	IF(N.NE.' ')GO TO 2
	N=ICHAR(J)
	GO TO 1
2	IF(NUMS(N).EQ.0)GO TO 3
4	LETNUM=2
	RETURN
3	IF(LETS(N).EQ.0)GO TO 40
CATCHES LETTERS AND MINUS SIGN (FOR INVIS. CLEFS)
7	LETNUM=1
	RETURN
40	DO 5 K=1,11
5	IF(N.EQ.MKS(K))GO TO (6,6,9,9,10,10,11,11,4,7,8)K
CCCC	CALL ERR(J)
6	LETNUM=3
C /  ;
	RETURN
8	LETNUM=8
C *   
	RETURN
9	LETNUM=4
C < >
	RETURN
10	LETNUM=5
C [ ]]
	RETURN
11	LETNUM=K-1
C ( )
	END
 
	SUBROUTINE OUTIT(I,K)
	DIMENSION I(1)
	IF(K.EQ.0)K=1
	I(K)=';'
	M=1
1	N=M+60
	DO 2 L=N,M,-1
	J=I(L)
2	IF(J.EQ.'/'.OR.J.EQ.';')GO TO 3
3	IF(L.GT.K)L=K
	WRITE(21,10)(I(J),J=M,L)
	TYPE 11,(I(J),J=M,L)
	IF(L.EQ.K)RETURN
	M=L+1
	GO TO 1
10	FORMAT(70A1)
11	FORMAT(1X70A1)
	END
 
	SUBROUTINE UPCNT
	COMMON /INP/JN,I(1) /J/J,JJ,JX
C GETS LAST NOTE NUM.
	K=J
	JR=0
1	K=K-1
	N=I(K)
	IF(NUMS(N))GO TO 1
	CALL A2I(K,N)
	IF(JR.NE.0)GO TO 4
	IF(JX.EQ.-99)GO TO 2
	JN=JN+N-1
	RETURN
2	JR=N
3	K=K-1
	IF(I(K).EQ.' ')GO TO 3
	GO TO 1
4	JN=JN+JR*N-N-1
	END
 
CC	SUBROUTINE ERR(J)
CC	COMMON /INP/JN,I(1)
CC	TYPE 1,(I(K),K=1,J)
CC1	FORMAT(1X80A1,/' ****** ERROR *****')
CC	STOP
CC	END
 
	SUBROUTINE READ(K)
	COMMON /INP/JN,I(80) 
10	FORMAT(80A1)
11	FORMAT(1X80A1)
1	READ(1,10,END=2)I
	IF(I(1).NE.'C')GO TO 4
	IF(I(2).NE.'O')GO TO 4
C FOR X!Z&#% ET DIRECTORY
5	READ(1,10)I
	IF(I(3).NE.';')GO TO 5
	GO TO 1
4	DO 3 K=80,1,-1
	N=I(K)
3	IF(N.EQ.'/'.OR.N.EQ.';')RETURN
CCC	IF(I(1).NE.'@')GO TO 1
C START LINE WITH '@' FOR LITERAL REPRODUCTION.
	DO 6 K=80,1,-1
6	IF(I(K).NE.' ')GO TO 7
7	WRITE(21,10)(I(L),L=1,K)
	TYPE 11,(I(L),L=1,K)
	GO TO 1
C IGNORES BLANK LINES OR UNTERMINATED LINES.
2	STOP
	END

	SUBROUTINE WRITER
	COMMON /LST/J1,J2,J3,J4,J5,NTS(1000),IRH(700),IM(500)
	1 ,IB(500),ISL(500)
2	CALL OUTIT(NTS,J1)
	CALL OUTIT(IRH,J2)
	CALL OUTIT(IM,J3)
	CALL OUTX(IB,J4)
	CALL OUTX(ISL,J5)
	END

	SUBROUTINE OUTX(IX,J)
	DIMENSION IX(1)
	COMMON /LST/J1,J2,J3,J4,J5,NTS(1000),IRH(700),IM(500)
	K=1
	IF(J.LE.1)GO TO 4
	IF(IX(2).NE.'B')GO TO 3
C NEXT FOR AUTO-BEAMS  (E.G. 2B;  3B1; ETC.)
	CALL OUTIT(IX,J)
	RETURN

3	DO 6 L=1,J,2
	MM=IX(L)
	IF(MM.GE.100)GO TO 5
	IF(MM.GE.0)GO TO 6
	IX(L)=-MM
CHANGE -M,N TO M,-N
	IX(L+1)=IX(L+1)+200
	GO TO 6
5	IX(L)=MM-100
CHANGES M+100,N TO M,N+100
	IX(L+1)=IX(L+1)+100
6	CONTINUE

	JJ=' '
	NN=1
	DO 1 L=1,J
	LL=IX(L)
	CALL I2A(LL,MM,M,N)
	IF(LL.LT.96)GO TO 7
	IF(LL.GE.99)GO TO 7
	IF(LL.EQ.98)GO TO 8
CC	MX=NTS(K-4)
	MY=NTS(K-3)
	MZ=NTS(K-2)
	NTS(K-4)='-'
	IF(LL.EQ.96)GO TO 10
	N='9'
	GO TO 11
10	M='0'
	N=MZ
11	NTS(K-3)=M
	NTS(K-2)=N
	M=MY
	N=MZ
	GO TO 7
C THESE ARE FOR SLURS BEFORE AND AFTER STAFF LIMIT
8	N='0'
	M='0'
7	NTS(K)=MM
	NTS(K+1)=M
	NTS(K+2)=N
	NTS(K+3)=JJ
	JJ='/'
	IF(NN)JJ=' '
	NN=-NN
1	K=K+4
	K=K-1
4	NTS(K)=';'
	DO 2 L=K+1,K+79
2	NTS(L)=' '
	CALL OUTIT(NTS,K)
	END
 
	FUNCTION ICHAR(J)
	COMMON /INP/JN,I(1)
	J=J+1
	ICHAR=I(J)
	END